home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 1 / Gold Medal Software Volume 1 (Gold Medal) (1994).iso / prog / tpwprog8.arj / SYSCOLOR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-07-02  |  16.5 KB  |  609 lines
  1. { syscolor.pas -- Set system colors }
  2.  
  3. { (c) 1991 by Tom Swan. All rights reserved. }
  4.  
  5. { From "Turbo Pascal for Windows 3.0 Programming" (Bantam, 1991) }
  6.  
  7. program SysColor;
  8.  
  9. {$R syscolor.res}
  10.  
  11. uses WinTypes, WinProcs, WObjects, Strings;
  12.  
  13. const
  14.  
  15.   app_Name  = 'SysColor';       { Application name }
  16.   ini_FName = 'SYSCOLOR.INI';   { .INI file name }
  17.  
  18.   id_Menu      = 100;           { Menu resource ID }
  19.   id_Icon      = 200;           { Icon resource ID }
  20.   cm_About     = 101;           { Menu:About command resource ID }
  21.   cm_Quit      = 102;           { Menu:Exit command resource ID }
  22.   id_SBarRed   = 100;           { Window control IDs }
  23.   id_SBarGrn   = 101;
  24.   id_SBarBlu   = 102;
  25.   id_SetBtn    = 103;
  26.   id_ResetBtn  = 104;
  27.   id_SaveBtn   = 105;
  28.   id_QuitBtn   = 106;
  29.  
  30.   RedMask = $000000FF;          { Color value extraction masks }
  31.   GrnMask = $0000FF00;
  32.   BluMask = $00FF0000;
  33.  
  34.   nonStop: Boolean = false;     { Use switches: -s = false; -n = true }
  35.  
  36. type
  37.  
  38.   SCApplication = object(TApplication)
  39.     constructor Init(AName: PChar);
  40.     procedure InitMainWindow; virtual;
  41.   end;
  42.  
  43.   PColorScrollBar = ^TColorScrollBar;
  44.   TColorScrollBar = object(TScrollBar)
  45.     Digits: PStatic;
  46.     constructor Init(AParent: PWindowsObject; AnID, Y: Integer;
  47.       ALabel: PChar; var SText: PStatic);
  48.     procedure SetupWindow; virtual;
  49.     procedure DefNotificationProc(var Msg: TMessage); virtual;
  50.     procedure SetDigits;
  51.     procedure SetPosition(ThumbPos: Integer); virtual;
  52.   end;
  53.  
  54.   PSCWindow = ^SCWindow;
  55.   SCWindow = object(TWindow)
  56.   {- Data fields }
  57.     Dc: Hdc;
  58.     ButtonDown, Changed: Boolean;
  59.     LineX1, LineY1, LineX2, LineY2: Integer;
  60.     ArrowCursor, CrossHairCursor: HCursor;
  61.     SBarRed, SBarGrn, SBarBlu: PColorScrollBar;
  62.     STxtRed, STxtGrn, STxtBlu: PStatic;
  63.     SampleRect: TRect;
  64.     SampleColor: TColorRef;
  65.     DraggingOrigin: Integer;
  66.   {- Methods }
  67.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  68.     destructor Done; virtual;
  69.     procedure SetupWindow; virtual;
  70.     procedure InitChildControls;
  71.     procedure ResetSystemColors;
  72.     procedure SynchronizeScrollBars;
  73.     procedure DrawRubberband;
  74.     function CanClose: Boolean; virtual;
  75.     procedure GetWindowClass(var AWndClass: TWndClass); virtual;
  76.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  77.     function InsideColorRect(X, Y: Integer; var Index: Integer): Boolean;
  78.     procedure CMAbout(var Msg: TMessage);
  79.       virtual cm_First + cm_About;
  80.     procedure CMQuit(var Msg: TMessage);
  81.       virtual cm_First + cm_Quit;
  82.     procedure WMHScroll(var Msg: TMessage);
  83.       virtual wm_First + wm_HScroll;
  84.     procedure WMLButtonDown(var Msg: TMessage);
  85.       virtual wm_First + wm_LButtonDown;
  86.     procedure WMLButtonUp(var Msg: TMessage);
  87.       virtual wm_First + wm_LButtonUp;
  88.     procedure WMMouseMove(var Msg: TMessage);
  89.       virtual wm_First + wm_MouseMove;
  90.     procedure SaveBtnEvent(var Msg: TMessage);
  91.       virtual id_First + id_SaveBtn;
  92.     procedure SetBtnEvent(var Msg: TMessage);
  93.       virtual id_First + id_SetBtn;
  94.     procedure QuitBtnEvent(var Msg: TMessage);
  95.       virtual id_First + id_QuitBtn;
  96.     procedure ResetBtnEvent(var Msg: TMessage);
  97.       virtual id_First + id_ResetBtn;
  98.   end;
  99.  
  100.   SysColorRec = record
  101.     OriginalColor: TColorRef;  { Color on starting program }
  102.     CurrentColor: TColorRef;   { New color selected by user }
  103.     SCRect: TRect;             { Location of system-color rectangle }
  104.   end;
  105.  
  106. var
  107.  
  108.   SysColorArray: Array[0 .. color_EndColors] of SysColorRec;
  109.   SysColorNames: Array[0 .. color_EndColors] of PChar;
  110.  
  111.  
  112. { Common routines }
  113.  
  114. {- Convert integer N to C char array. If Max > 0, pad with 0s. }
  115. procedure Int2Str(N, Max: Integer; C: PChar);
  116. var
  117.   S: String[6];
  118. begin
  119.   Str(N, S);
  120.   while Length(S) < Max do S := '0' + S;
  121.   StrPCopy(C, S)
  122. end;
  123.  
  124. {- Prepare global SysColorArray with current color values }
  125. procedure InitSysColorArray;
  126. var
  127.   I: Integer;
  128. begin
  129.   for I := 0 to color_EndColors do with SysColorArray[I] do
  130.   begin
  131.     OriginalColor := GetSysColor(I);
  132.     CurrentColor := OriginalColor;
  133.     with SCRect do
  134.     begin
  135.       Left := 500;
  136.       Top := 20 + (I * 20);
  137.       Right := 600;
  138.       Bottom := Top + 15
  139.     end
  140.   end
  141. end;
  142.  
  143. {- Change system colors to values in SysColorArray }
  144. procedure ChangeSystemColors;
  145. var
  146.   I: Integer;
  147.   InxArray: Array[0 .. color_EndColors] of Integer;
  148.   ClrArray: Array[0 .. color_EndColors] of TColorRef;
  149. begin
  150.   for I := 0 to color_EndColors do
  151.   begin
  152.     InxArray[I] := I;
  153.     ClrArray[I] := SysColorArray[I].CurrentColor
  154.   end;
  155.   SetSysColors(color_EndColors + 1, InxArray[0], ClrArray[0])
  156. end;
  157.  
  158. {- Save colors to SYSCOLOR.INI in Windows directory }
  159. function SaveSettings: Boolean;
  160. var
  161.   I: Integer;
  162.   S: String[12];
  163.   NewValue: array[0 .. 12] of Char;
  164. begin
  165.   SaveSettings := true;  { Think positively! }
  166.   for I := 0 to color_EndColors do with SysColorArray[I] do
  167.   begin
  168.     Str(CurrentColor, S);
  169.     StrPCopy(NewValue, S);
  170.     if not WritePrivateProfileString(app_Name, SysColorNames[I],
  171.       NewValue, ini_FName) then
  172.     begin
  173.       SaveSettings := false;
  174.       Exit
  175.     end
  176.   end
  177. end;
  178.  
  179. {- Load colors from SYSCOLOR.INI if present }
  180. procedure LoadSettings;
  181. var
  182.   I, Err: Integer;
  183.   S: String[12];
  184.   DefaultValue, NewValue: array[0 .. 12] of Char;
  185. begin
  186.   for I := 0 to color_EndColors do with SysColorArray[I] do
  187.   begin
  188.     Str(CurrentColor, S);
  189.     StrPCopy(DefaultValue, S);
  190.     GetPrivateProfileString(app_Name, SysColorNames[I],
  191.       DefaultValue, NewValue, sizeof(NewValue), ini_FName);
  192.     S := StrPas(NewValue);
  193.     Val(S, CurrentColor, Err);
  194.     if Err <> 0 then CurrentColor := OriginalColor
  195.   end;
  196.   GetPrivateProfileString(app_Name, 'nonstop',
  197.     'false', NewValue, sizeof(NewValue), ini_FName);
  198.   if StrComp('false', NewValue) <> 0
  199.     then nonStop := true
  200. end;
  201.  
  202. {- Get command-line switches }
  203. procedure GetSwitches;
  204. var
  205.   I: Integer;
  206.   S: String[128];
  207.   C: Char;
  208. begin
  209.   for I := 1 to ParamCount do
  210.   begin
  211.     S := ParamStr(I);
  212.     C := upcase(S[1]);
  213.     if (Length(S) > 1) and ((C = '-') or (C = '/')) then
  214.     case upcase(S[2]) of
  215.       'N' : nonStop := true;
  216.       'S' : nonStop := false
  217.     end
  218.   end
  219. end;
  220.  
  221.  
  222. { SCApplication }
  223.  
  224. {- Construct SCApplication object }
  225. constructor SCApplication.Init(AName: PChar);
  226. begin
  227.   TApplication.Init(AName);
  228.   InitSysColorArray;          { Initialize colors }
  229.   LoadSettings;               { Load .INI settings if present }
  230.   GetSwitches;                { Get command-line switches }
  231.   if nonStop then
  232.   begin                       { Optional nonstop operation: }
  233.     ChangeSystemColors;       { Change colors to .INI settings }
  234.     MainWindow^.CloseWindow   { Exit application }
  235.   end;
  236. end;
  237.  
  238. {- Initialize application's window }
  239. procedure SCApplication.InitMainWindow;
  240. begin
  241.   MainWindow := New(PSCWindow, Init(nil, 'Set System Colors'))
  242. end;
  243.  
  244.  
  245. { TColorScrollBar }
  246.  
  247. {- Construct TColorScrollBar instance }
  248. constructor TColorScrollBar.Init(AParent: PWindowsObject;
  249.   AnID, Y: Integer; ALabel: PChar; var SText: PStatic);
  250. begin
  251.   TScrollBar.Init(AParent, AnID, 50, Y, 250, 18, true);
  252.   New(SText, Init(AParent, -1, ALabel, 5, Y, 40, 18, 40));
  253.   New(Digits, Init(AParent, -1, '000', 310, Y, 40, 18, 3));
  254.   SText := Digits  { Return pointer to control's digital "readout" }
  255. end;
  256.  
  257. {- Set scroll bar range for a byte color value }
  258. procedure TColorScrollBar.SetupWindow;
  259. begin
  260.   TScrollBar.SetupWindow;
  261.   SetRange(0, 255)
  262. end;
  263.  
  264. {- Change digital readout for changes to scroll bar position }
  265. procedure TColorScrollBar.DefNotificationProc(var Msg: TMessage);
  266. begin
  267.   SetDigits;
  268.   TScrollBar.DefNotificationProc(Msg)
  269. end;
  270.  
  271. {- Change digital readout to match current position }
  272. procedure TColorScrollBar.SetDigits;
  273. var
  274.   C: array[0 .. 3] of Char;
  275. begin
  276.   Int2Str(GetPosition, 3, C);
  277.   Digits^.SetText(C)
  278. end;
  279.  
  280. {- Force scroll bar to specific position }
  281. procedure TColorScrollBar.SetPosition(ThumbPos: Integer);
  282. begin
  283.   TScrollBar.SetPosition(ThumbPos);
  284.   SetDigits
  285. end;
  286.  
  287.  
  288. { SCWindow }
  289.  
  290. {- Construct SCWindow object and instantiate child windows }
  291. constructor SCWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  292. begin
  293.   TWindow.Init(AParent, ATitle);
  294.   EnableKBHandler;
  295.   Attr.Menu := LoadMenu(HInstance, PChar(id_Menu));
  296.   with Attr do
  297.   begin
  298.     X := 10; Y := 10; H := 460; W := 615
  299.   end;
  300.   ButtonDown := false;
  301.   Changed := false;
  302.   ArrowCursor := LoadCursor(0, idc_Arrow);
  303.   CrossHairCursor := LoadCursor(0, idc_Cross);
  304.   SampleColor := 0;
  305.   with SampleRect do
  306.   begin
  307.     Left := 200; Top := 150; Right := 300; Bottom := 230;
  308.   end;
  309.   InitChildControls
  310. end;
  311.  
  312. {- Finish window preparation }
  313. procedure SCWindow.SetupWindow;
  314. var
  315.   I: Integer;
  316.   Buffer: array[0 .. 40] of Char;
  317. begin
  318.   TWindow.SetupWindow;
  319.   SetFocus(ChildList^.HWindow);
  320.   for I := 0 to color_EndColors do
  321.   begin
  322.     LoadString(HInstance, I, Buffer, 40);
  323.     SysColorNames[I] := StrNew(Buffer)
  324.   end
  325. end;
  326.  
  327. {- Destroy SCWindow instance }
  328. destructor SCWindow.Done;
  329. var
  330.   I: Integer;
  331. begin
  332.   for I := 0 to color_EndColors do
  333.     StrDispose(SysColorNames[I]);
  334.   TWindow.Done
  335. end;
  336.  
  337. {- Create and initialize child controls in window }
  338. procedure SCWindow.InitChildControls;
  339. var
  340.   AControl: PControl;  { Throw-away control pointer }
  341. begin
  342.   SBarRed := New(PColorScrollBar, Init(@Self, id_SBarRed, 20,
  343.     'Red', STxtRed));
  344.   SBarGrn := New(PColorScrollBar, Init(@Self, id_SBarGrn, 60,
  345.     'Green', STxtGrn));
  346.   SBarBlu := New(PColorScrollBar, Init(@Self, id_SBarBlu, 100,
  347.     'Blue', STxtBlu));
  348.   AControl    := New(PButton, Init(@Self, id_SetBtn,
  349.     'Se&t',   50, 150, 80, 40, false));
  350.   AControl    := New(PButton, Init(@Self, id_ResetBtn,
  351.     '&Reset', 50, 210, 80, 40, false));
  352.   AControl    := New(PButton, Init(@Self, id_SaveBtn,
  353.     '&Save',  50, 270, 80, 40, false));
  354.   AControl    := New(PButton, Init(@Self, id_QuitBtn,
  355.     '&Quit',  50, 330, 80, 40, true))
  356. end;
  357.  
  358. {- Return true if window may close }
  359. function SCWindow.CanClose: Boolean;
  360. var
  361.   Answer: Integer;
  362. begin
  363.   CanClose := true;
  364.   if Changed then
  365.   begin
  366.     Answer := MessageBox(HWindow, 'Save colors before quitting?',
  367.       'Please answer', mb_YesNoCancel or mb_IconQuestion);
  368.     if Answer = idYes then
  369.       CanClose := SaveSettings
  370.     else if Answer = idCancel then
  371.       CanClose := false
  372.   end
  373. end;
  374.  
  375. {- Reset system colors to values saved at start of program }
  376. procedure SCWindow.ResetSystemColors;
  377. var
  378.   I: Integer;
  379. begin
  380.   for I := 0 to color_EndColors do with SysColorArray[I] do
  381.     CurrentColor := OriginalColor;
  382.   Changed := false
  383. end;
  384.  
  385. {- Modify window class to use custom icon }
  386. procedure SCWindow.GetWindowClass(var AWndClass: TWndClass);
  387. begin
  388.   TWindow.GetWindowClass(AWndClass);
  389.   AWndClass.hIcon := LoadIcon(HInstance, PChar(id_Icon))
  390. end;
  391.  
  392. {- Adjust scroll bars to match SampleColor }
  393. procedure SCWindow.SynchronizeScrollBars;
  394. var
  395.   DummyMsg: TMessage;
  396. begin
  397.   SBarRed^.SetPosition(SampleColor and RedMask);
  398.   SBarGrn^.SetPosition((SampleColor and GrnMask) shr 8);
  399.   SBarBlu^.SetPosition((SampleColor and BluMask) shr 16);
  400.   WMHScroll(DummyMsg)  { Force scroll bar update }
  401. end;
  402.  
  403. {- Display "About program" dialog box }
  404. procedure SCWindow.CMAbout(var Msg: TMessage);
  405. var
  406.   Dialog: TDialog;
  407. begin
  408.   Dialog.Init(@Self, 'About');
  409.   Dialog.Execute;
  410.   Dialog.Done
  411. end;
  412.  
  413. {- Execute Menu:Exit command }
  414. procedure SCWindow.CMQuit(var Msg: TMessage);
  415. begin
  416.   CloseWindow
  417. end;
  418.  
  419. {- Draw rubberband connecting line while dragging colors }
  420. procedure SCWindow.DrawRubberband;
  421. begin
  422.   MoveTo(Dc, LineX1, LineY1);
  423.   LineTo(Dc, LineX2, LineY2)
  424. end;
  425.  
  426. {- Return true if point X, Y is inside a color rectangle }
  427. function SCWindow.InsideColorRect(X, Y: Integer;
  428.   var Index: Integer): Boolean;
  429. var
  430.   CursorLocation: TPoint;
  431.   I: Integer;
  432. begin
  433.   CursorLocation.X := X;
  434.   CursorLocation.Y := Y;
  435.   InsideColorRect := true;
  436.   if PtInRect(SampleRect, CursorLocation) then
  437.   begin
  438.     Index := -1;      { Inside sample color box }
  439.     Exit
  440.   end else
  441.   for I := 0 to color_EndColors do
  442.     if PtInRect(SysColorArray[I].SCRect, CursorLocation) then
  443.     begin
  444.       Index := I;     { Inside a system color rectangle }
  445.       Exit
  446.     end;
  447.   InsideColorRect := false
  448. end;
  449.  
  450. {- Change color rectangle when a scroll bar moves }
  451. procedure SCWindow.WMHScroll(var Msg: TMessage);
  452. begin
  453.   TWindow.WMHScroll(Msg);
  454.   SampleColor := RGB(SBarRed^.GetPosition, SBarGrn^.GetPosition,
  455.     SBarBlu^.GetPosition);
  456.   InvalidateRect(HWindow, @SampleRect, False)
  457. end;
  458.  
  459. {- Handle left-button down event }
  460. procedure SCWindow.WMLButtonDown(var Msg: TMessage);
  461. begin
  462.   if not ButtonDown then with Msg do
  463.   if InsideColorRect(LParamLo, LParamHi, DraggingOrigin) then
  464.   begin
  465.     Dc := GetDC(HWindow);
  466.     LineX1 := LParamLo;
  467.     LineY1 := LParamHi;
  468.     LineX2 := LineX1;
  469.     LineY2 := LineY1;
  470.     SetROP2(Dc, r2_Not);
  471.     DrawRubberband;
  472.     ButtonDown := true;
  473.     SetCursor(CrossHairCursor);
  474.     SetCapture(HWindow);
  475.     if DraggingOrigin >= 0 then {- Clicked in a system color rect }
  476.     begin
  477.       SampleColor := SysColorArray[DraggingOrigin].CurrentColor;
  478.       SynchronizeScrollBars
  479.     end
  480.   end
  481. end;
  482.  
  483. {- Handle left-button up event }
  484. procedure SCWindow.WMLButtonUp(var Msg: TMessage);
  485. var
  486.   Index: Integer;
  487.   NewColor: TColorRef;
  488. begin
  489.   if ButtonDown then with Msg do
  490.   begin
  491.     if InsideColorRect(LParamLo, LParamHi, Index) then
  492.     if (Index <> DraggingOrigin) and (Index >= 0) then
  493.     begin
  494.       Changed := true;
  495.       if DraggingOrigin >= 0
  496.         then NewColor := SysColorArray[DraggingOrigin].CurrentColor
  497.         else NewColor := SampleColor;
  498.       SysColorArray[Index].CurrentColor := NewColor;
  499.       InvalidateRect(HWindow, nil, False)
  500.     end;
  501.     DrawRubberband;         { Erase last line }
  502.     SetROP2(Dc, r2_Black);
  503.     ButtonDown := false;
  504.     SetCursor(ArrowCursor);
  505.     ReleaseDC(HWindow, Dc);
  506.     ReleaseCapture
  507.   end
  508. end;
  509.  
  510. {- Handle mouse-move event }
  511. procedure SCWindow.WMMouseMove(var Msg: TMessage);
  512. begin
  513.   if ButtonDown then
  514.   begin
  515.     DrawRubberband;         { Erase old line }
  516.     with Msg do
  517.     begin
  518.       LineX2 := LParamLo;
  519.       LineY2 := LParamHi;
  520.       DrawRubberband        { Draw new line }
  521.     end
  522.   end
  523. end;
  524.  
  525. {- Respond to Set button selection }
  526. procedure SCWindow.SetBtnEvent(var Msg: TMessage);
  527. begin
  528.   ChangeSystemColors
  529. end;
  530.  
  531. {- Respond to Reset button selection }
  532. procedure SCWindow.ResetBtnEvent(var Msg: TMessage);
  533. begin
  534.   ResetSystemColors;
  535.   ChangeSystemColors
  536. end;
  537.  
  538. {- Respond to Save button selection }
  539. procedure SCWindow.SaveBtnEvent(var Msg: TMessage);
  540. begin
  541.   if SaveSettings then Changed := false
  542. end;
  543.  
  544. {- Respond to Quit button selection }
  545. procedure SCWindow.QuitBtnEvent(var Msg: TMessage);
  546. begin
  547.   CloseWindow
  548. end;
  549.  
  550. {- Paint window contents }
  551. procedure SCWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  552. var
  553.   OldBrush, TheBrush: HBrush;
  554.   I: Integer;
  555.  
  556.   procedure ShowSysColor(I: Integer);
  557.   var
  558.     SysColorBrush : HBrush;
  559.     OldBrush: HBrush;
  560.     SCName : PChar;
  561.   begin
  562.     with SysColorArray[I], SCRect do
  563.     begin
  564.       SysColorBrush := CreateSolidBrush(CurrentColor);
  565.       OldBrush := SelectObject(PaintDC, SysColorBrush);
  566.       Rectangle(PaintDC, Left, Top, Right, Bottom);
  567.       SelectObject(PaintDC, OldBrush);
  568.       DeleteObject(SysColorBrush);
  569.       SCName := SysColorNames[I];
  570.       TextOut(PaintDC, Left - 125, Top, SCName, StrLen(SCName))
  571.     end
  572.   end;
  573.  
  574. begin
  575.   TheBrush := CreateSolidBrush(SampleColor);
  576.   OldBrush := SelectObject(PaintDC, TheBrush);
  577.   with SampleRect do Rectangle(PaintDC, Left, Top, Right, Bottom);
  578.   SelectObject(PaintDC, OldBrush);
  579.   DeleteObject(TheBrush);
  580.   for I := 0 to color_EndColors do
  581.     ShowSysColor(I)
  582. end;
  583.  
  584. var
  585.  
  586.   SCApp: SCApplication;
  587.  
  588. begin
  589.   SCApp.Init(app_Name);
  590.   SCApp.Run;
  591.   SCApp.Done
  592. end.
  593.  
  594.  
  595. { --------------------------------------------------------------
  596.   Copyright (c) 1991 by Tom Swan. All rights reserved.
  597.   Revision 1.00    Date: 2/1/1991
  598.   Revision 1.01    Date: 2/27/1991
  599.   1. Changed all cm_Exit constants to cm_Quit
  600.   2. Changed all CMExit procedure names to CMQuit
  601.   3. Added length argument to all TStatic object inits
  602.   Revision 1.02    Date: 5/11/1991
  603.   1. Changed all PostQuitMessage calls to CloseWindow
  604.   2. Added TColorScrollBar object
  605.   3. Enabled (limited) keyboard use of controls
  606.   4. Added hot key letters to buttons
  607.   5. Moved most string constants to string table resource
  608.   ------------------------------------------------------------- }
  609.